COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(df indexf (f)
C00011 ENDMK
C⊗;
(df indexf (f)
		; appel: (indexf filename) ;
  (indexfile ['dsk (cons (car f) 'vlx)] (car f) (cadr f)))
 
(de indexfile (filout filin ?sw1 ;; f nfnts)
  ; si ?sw1 = T, on trie ;
  (setq nfnts 1) ; init n0 de page ;
  (output filout)
  (status 2 20)
  (prcomment (incr nfnts) (princ '* 30)
	      (prin1 (date) (time)))
  (terpri 2)
  (input filin)
  (escape &exit
    (de eof () (remprop 'eof expr) 
	; impression de l'index ;
	(setq -lindex (if ?sw1 (sortl -lindex) (freverse -lindex)))
	(mapc -lindex 
	      (lambda (nom) (mapc (get nom 'using)
				  (lambda (f) 
				     (nconc1 (get f 'usedby) nom)))))
	(while -lindex
	  (terpri 3) (ttab 10) (princ '- 10)
	  (prin1 (setq -nom (nextl -lindex)))
	  (princ '/  1) (princ '- 10) (terpri 2)
	  (mapc '(type args fvars fvarset strings using)
		 (lambda (x ;; y)
		    (and (setq y (get -nom x))
			 (print-x x '/= y))))
	  (and (setq f (cdr (get -nom 'usedby)))
	       (print-x 'usedby '= (opsort f))))
	(status 1 20)
	(terpri)
	(prcomment (princ '* 30) (prin1 (date) (time) 'indexend))
	(terpri)
	(input)
	(output)
	(&exit filout))

    (setq -lindex nil)

    (while t
	(setq f (read))
	(if (listp f) (selectq (car f)
			(pour (if (eq (cadr f) 'index) (eprogn (cddr f))))
			((de df dm dmi dmo dmc)
                	     (casecallform f)
                	     (newl -lindex (cadr f))
                	     (anadef f))
			 ())))
  ))


(df prcomment (evl) ;edite entre points et virgules;
  (princ (ascii 59))
  (eprogn evl)
  (spaces 1)
  (princ (ascii 59)))

(de suins (l liees type) 
  ; L = une suite (e1 ... en) . On anaobe chaque ei ;
  ; type = T dans un PROG-body ;
  (while l (anaob (nextl l))))

(de anaob (l ;; x y) (cond
  ((numbp l))
  ((stringp l) (add l 'strings))
  ((atom l) (or type (voir l)))
  ((atom (setq x (car l)))
   ; function call ou clause-de-cond ;
   (setq y (cadr l))
   (selectq x
	((function quote) (and (listp y) (anaclause y liees)))
	       ; regle le cas des '(lambda ...) ;
	((newl setq) (voir y t) (anaob (caddr l)) 
	       (and (cdddr l) (anaob (cons 'setq (cdddr l)))))
	((incr decr) (voir y y))
	(setqq (voir y t) (and (cdddr l) 
			       (cons 'setq (cdddr l))))
	(setqa (voir y t) (suins (cddr l) liees))
	((lambda prog escape) (anaclause l liees))
	((go nil))
	(t (suins (cdr l) liees))
	((maparray maparrayq map mapc mapcar mapct maplist
          maps mapst mapsub mapt some every)
         (anaob (cadr l) liees) (anaclause (caddr l) liees))
	(maparrayq (voir y t) (anaclause (caddr l) liees))
	(apply (anaclause y liees) (anaob (caddr l) liees))
	(selectq  (anaob y liees) (setq x (cddr l))
		  (while (cdr x) (suins (cdr (nextl x)) liees))
		  (suins (nextl x) liees))
	(cond     (setq x (cdr l))
		  (while x (suins (nextl x) liees)))
	((de df dm dmi dmo dmc) (casecallform l)
			        (newl -lindex y)
				(anadef l))
	((cond
	   ((setq y (get x 'macro)) (anaob (apply y [l])))
	   ((numbp x))
	   ((or (standard x) (user x)) (suins (cdr l) liees))))))
  (t (suins l liees)) ))

(de voir (x y) 
  ; x : une possible variable libre ;
  ; y = T dans le cas de SETQ  ou de NEWL ou de INCR ou de DECR ;
  ;		   ou de SETQA  ou de MAPARRAYQ  ou de SETQQ ;
  (or (numbp x) (memq x '(t quote lambda expr fexpr macro nil))
      (memq x liees)
      (progn
        (and y (add x 'fvarset))
        (add x 'fvars))))

(de anaclause (l liees ;; x y)
  (if (atom l) (or (numbp l) (standard l) (user l))
      (setq x (car l) y (cadr l))
      (selectq x
	(quote (if (listp y) (anaclause y liees) 
		   (or (numbp y) (standard y) (user y))))
	(lambda (suins (cddr l) (append (and y (linear y)) liees)))
	(escape (suins (cddr l) (cons y liees)))
	(prog (suins (cddr l) (append y liees) t))
	())))

(de user (x) (or (memq x liees) (add x 'using)))

(de standard (f) (or (le (loc f) (loc 'stop))
		     (getl f '(expr fexpr macro macin macout))))


(de add (ob v) 
  (let ((val (eval v)))
    (or (memq ob val) (set v (cons ob val)))))

(de sortl (l) ; trier la liste l de pnames ;
  (if l 
      (let ((x (nextl l)) (l (self l))) (cond
	((null l) [x])
	((sort x (car l)) (cons x l))
	(t (cons (nextl l) (self x l)))))))

(de opsort (x) (if ?sw1 (sortl x) x))

(de print-x l 
  (prin1 (car l) (cadr l))
  (status 7 (plus 2 (status 8)))
  (apply 'prin1 (cddr l))
  (status 7 0)
  ; i.e. coller le temps de l'impression la marge gauche ;
  ; a la place ou elle se trouve apres le "=" , et restorer ;
  (TERPRI))

(de anadef (l ;; fvars fvarset using strings)
  (apply (lambda (type nom args . body)
	    (putm nom (cassq type '((de . expr) (df . fexpr)
				    (dm . macro) (dmi . macin)
				    (dmo . macout) (dmc . mchar)))
		      'type
		       args 'args)
	    (suins body (and args (linear args)))
	    (putm nom (opsort (freverse fvars)) 'fvars
		      (opsort (freverse fvarset)) 'fvarset
		      (opsort (freverse using)) 'using
		      (freverse strings) 'strings
		      [nil] 'usedby))
          l))

(de putm l
  (let ((nom (nextl l)))
	(while l (put nom (nextl l) (nextl l)))
	nom))

(de casecallform (l ;; x) ; smashes a call-form definition ;
    (and (listp (cadr l))
	 (rplaca (cdr l) (car (setq x (cadr l))))
	 (rplacd (cdr l) (rplacd (rplaca x (cdr x)) (cddr l))))
    l)